home *** CD-ROM | disk | FTP | other *** search
/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / c / lmistr.lsp < prev    next >
Encoding:
Text File  |  1988-08-16  |  27.6 KB  |  689 lines
  1. ;;; -*- Mode:LISP; Package:S-TERMINAL; Base:10; Readtable:T -*-
  2.  
  3. ;******************************************************************************
  4. ; Copyright (c) 1984, 1985 by Lisp Machine Inc.
  5. ; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
  6. ; Permission to copy all or part of this material is granted, provided
  7. ; that the copies are not made or distributed for resale, and the 
  8. ; copyright notices and reference to the source file and the software
  9. ; distribution version appear, and that notice is given that copying is
  10. ; by permission of Lisp Machine Inc.  LMI reserves for itself the 
  11. ; sole commercial right to use any part of this KERMIT/H19-Emulator
  12. ; not covered by any Columbia University copyright.  Inquiries concerning
  13. ; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
  14. ;
  15. ; Version Information:
  16. ;      LMKERMIT 1.0     --      Original LMI code, plus edit ;1; for 3600 port
  17. ;
  18. ; Authorship Information:
  19. ;      Mark David (LMI)           Original version, using KERMIT.C as a guide
  20. ;      George Carrette (LMI)      Various enhancements
  21. ;      Mark Ahlstrom (Honeywell)  Port to 3600 (edits marked with ";1;" comments)
  22. ;
  23. ; Author Addresses:
  24. ;      George Carrette     ARPANET: GJC at MIT-MC
  25. ;
  26. ;      Mark Ahlstrom       ARPANET: Ahlstrom at HI-Multics
  27. ;                          PHONE:   (612) 887-4006
  28. ;                          USMAIL:  Honeywell MN09-1400
  29. ;                                   Computer Sciences Center
  30. ;                                   10701 Lyndale Avenue South
  31. ;                                   Bloomington, MN  55420
  32. ;******************************************************************************
  33.  
  34.  
  35. ;;; a stream based on an ascii serial stream which can be
  36. ;;; the value of terminal-io (perhaps).
  37. ;;; 5/15/84 10:39:58 -George Carrette
  38.  
  39. ;;; the first thing to do is make a primitive terminal, enough to support
  40. ;;; a printing terminal, and determine what messages are really required.
  41. ;;; eventually implement enough options to support the STREAM-MIXIN rubout
  42. ;;; handler, except of course that some terminals cannot.
  43.  
  44. ;;; the PS-TERMINAL does not handle asyncronous input (such as would signal
  45. ;;; SYS:ABORT and other conditions), as such it is suitable for
  46. ;;; simple command-interpreter applications but not ideally suited for
  47. ;;; use as a lisp-listener terminal-io. In order to handle asyncronous input
  48. ;;; one needs a ps-terminal-keyboard-process, and signal conditions
  49. ;;; in other processes.
  50.  
  51. ;;; 2/03/85 16:05:21 The protocal for rubout handlers has gotten a bit
  52. ;;; hairier still for system 99. So this is about the right time to
  53. ;;; punt this code and write something with handles cursorpos, interrupt characters,
  54. ;; (e.g. hack <SYSTEM> etc by using ITS-style ^_)  and takes the STREAM-MIXIN.
  55.  
  56.  
  57. (defflavor ps-terminal
  58.              (serial
  59.               peek-chars
  60.               (cursor-x 0)
  61.               (cursor-y 0)
  62.               buffer
  63.               read-ahead-chars
  64.               ttysync
  65.               status)
  66.              ()
  67.   :initable-instance-variables)
  68.  
  69. (defvar *punt-output-next* nil)
  70.  
  71. (defmacro with-puntable-output (&body body)
  72.   `(*catch '*punt-output-next*
  73.      (let ((*punt-output-next* t))
  74.        ,@body)))
  75.  
  76. (defmethod (ps-terminal :raw-stream) ()
  77.   serial)
  78.  
  79. (defun make-ps-terminal ()
  80.   (make-instance 'ps-terminal
  81.                      ':serial (open "Sdu-port-b:")
  82.                      ':peek-chars nil
  83.                      ':read-ahead-chars nil
  84.                      ':ttysync t))
  85.  
  86. (defmethod (ps-terminal :subtyi) ()
  87.   (char-spy
  88.     (let ((c (if read-ahead-chars
  89.                      (pop read-ahead-chars)
  90.                  (send serial ':tyi))))
  91.       (cond ((memq c '(#o10 #o11 #o12 #o14 #o15))
  92.                (+ c #o200))
  93.               ((< c #o40)
  94.                (set-char-bit (logxor #o100 c) :control 1))
  95.               ((= c #o177)
  96.                #\rubout)
  97.               ('else
  98.                c)))))
  99.  
  100. (defvar *char-spy? nil "NIL, T, :CHAR or :BARE")
  101.  
  102. (defun char-spy (x)
  103.   (cond ((null *char-spy?))
  104.           ((eq *char-spy? :char)
  105.            (print (code-char x)))
  106.           ((eq *char-spy? :bare)
  107.            (print x))
  108.           ('else
  109.            (if (<= 0 x 256)
  110.                (tyo x)
  111.              (print (code-char x)))))
  112.   x)
  113.  
  114. #-3600
  115. (defmethod (ps-terminal :tyi) (&optional ignore)
  116.   (send self ':any-tyi))
  117.  
  118. (defvar *rubout-handler-echo? t
  119.   "If T (default) echo when rubout handling, otherwise dont. NIL is useful
  120. when reading passwords or on a half-duplex line.")
  121.  
  122. #-3600
  123. (defmethod (ps-terminal :any-tyi) (&optional ignore)
  124.   (cond (peek-chars
  125.            (pop peek-chars))
  126.           ((not tv:rubout-handler)
  127.            (send self ':subtyi))
  128.           ('else
  129.            (when (memq status '(:restored :initial-entry))
  130.              ;; this bizzare new "place" to put the prompting evidently related to
  131.              ;; fixing a bug in preemptable read rubout handler redisplay.
  132.              (setq status nil)
  133.              ;;Prompt if desired
  134.              (let ((prompt-option (assq :prompt tv:rubout-handler-options)))
  135.                (when prompt-option
  136.                  (tv:rubout-handler-prompt (cadr prompt-option) self nil)))
  137.              (setq tv:rubout-handler-starting-x cursor-x tv:rubout-handler-starting-y cursor-y))
  138.            (do ((ch)(rubout? nil)
  139.                 (activation-handler (assq :activation tv:rubout-handler-options)))
  140.                (nil)
  141.              (setq ch (send self ':subtyi))
  142.              (selectq ch
  143.                (#\rubout
  144.                 (cond ((null buffer))
  145.                         ('else
  146.                          (and *rubout-handler-echo? (send self ':tyo (pop buffer)))
  147.                          (setq rubout? t))))
  148.                (#\form
  149.                 (send self #+3600 :clear-window #-3600 ':clear-screen)    ;1;
  150.                 (send self ':redisplay ch))
  151.                (#\control-r
  152.                 (send self ':fresh-line)
  153.                 (send self ':redisplay ch))
  154.                (#\control-u
  155.                 (cond ((null buffer))
  156.                         ('else
  157.                          (send self ':fresh-line)
  158.                          (setq buffer nil)
  159.                          (setq peek-chars nil)
  160.                          (send self ':redisplay ch)
  161.                          (*THROW 'tv:RUBOUT-HANDLER t))))
  162.                ((or (not (graphic-char-p c))
  163.                       (not (mem #'char= c '(#\return #\tab #\line #\control-g))))
  164.                 ;; if this is the case then we dont want to deal with it.
  165.                 ;; a safety feature for ignoring bogus input that can cause
  166.                 ;; race conditions when talking to /dev/ttyl?. We are being
  167.                 ;; over cautious here, since we could just reject known losers.
  168.                 ;; Instead, allow only known winners.
  169.                 )
  170.                (t
  171.                 (push ch buffer)
  172.                 ;; why readers (case in point, READLINE) require this translation
  173.                 ;; to be handled by the rubout handler, that is, really why the readers
  174.                 ;; couldnt be modularized in some other way, well.
  175.                 (cond ((and activation-handler
  176.                                 (apply (cadr activation-handler) ch #-3600 (cddr activation-handler)))    ;1;
  177.                          (setq ch `(:activation ,ch 1))
  178.                          (setq tv:rubout-handler-activation-character ch))
  179.                         (*rubout-handler-echo?
  180.                          ;; having the reader actually do the echoing of the
  181.                          ;; activation character harkens back to extremely dark
  182.                          ;; ages indeed. Maybe the system is mature enough now
  183.                          ;; to lose all semblance of modularity.
  184.                          (send self ':tyo ch)))
  185.                 (cond (rubout?
  186.                          (setq peek-chars (reverse buffer))
  187.                          (*THROW 'tv:RUBOUT-HANDLER t))
  188.                         ('else
  189.                          (setq tv:rubout-handler-activation-character nil)
  190.                          (return ch)))))))))
  191.  
  192. #-3600
  193. (defmethod (ps-terminal :redisplay) (ch &aux len)
  194.   (AND (SETQ LEN (OR (ASSQ ':REPROMPT tv:RUBOUT-HANDLER-OPTIONS)
  195.                          (ASSQ ':PROMPT tv:RUBOUT-HANDLER-OPTIONS)))
  196.        (tv:RUBOUT-HANDLER-PROMPT (CADR LEN) SELF CH))
  197.   (and *rubout-handler-echo?
  198.        (dolist (c (reverse buffer))
  199.            (send self ':tyo c)))
  200.   (send self ':tyi))
  201.  
  202. (defmethod (ps-terminal :tyipeek) ()
  203.   (cond ((null peek-chars)
  204.            (setq peek-chars (list (send self ':tyi)))))
  205.   (car peek-chars))
  206.  
  207. (defmethod (ps-terminal :untyi) (c)
  208.   (push c peek-chars))
  209.  
  210. (defmethod (ps-terminal :tyo) (c)
  211.   (cond ((char-equal #\return c)
  212.            (send self ':terpri))
  213.           ('else
  214.            (if (eq ttysync ':all) (send self ':ttysync-action))
  215.            (cond ((graphic-char-p c)
  216.                     (setq cursor-x (1+ cursor-x))
  217.                     (send serial ':tyo c))
  218.                  ('else
  219.                     (format self "#\~A" (char-name c)))))))
  220.  
  221.  
  222. (defmethod (ps-terminal :terpri) ()
  223.   ;; we must allow some kind of flow control since there is no
  224.   ;; more processing. also at 9600 baud output is observed to be
  225.   ;; far more than a timesharing system can take.
  226.   (setq cursor-x 0)
  227.   (setq cursor-y (1+ cursor-y))
  228.   (send serial ':tyo #o15)
  229.   (send serial ':tyo #o12)
  230.   (if ttysync (send self ':ttysync-action)))
  231.  
  232. (defmethod (ps-terminal :ttysync-action) ()
  233.   ;; crude but effective.
  234.   (do ((c))
  235.       ((null (send serial ':listen)))
  236.     (setq c (send serial ':tyi))
  237.     (cond ((= c #o23)                                       ; ^S
  238.              (return (do ()
  239.                            (nil)
  240.                          (setq c (send serial ':tyi))
  241.                          (cond ((= c #o23))
  242.                                  ((= c #o17)          ; ^O
  243.                                   (if *punt-output-next* (*throw '*punt-output-next* nil)))
  244.                                  ((= c #o21)                ; ^Q
  245.                                   (return t))
  246.                                  ('else
  247.                                   (setq read-ahead-chars (nconc read-ahead-chars (list c))))))))
  248.             ((= c #o17)          ; ^O
  249.              (if *punt-output-next* (*throw '*punt-output-next* nil)))
  250.             ((= c #o21))
  251.             ('else
  252.              (setq read-ahead-chars (nconc read-ahead-chars (list c)))))))
  253.  
  254. (defmethod (ps-terminal :clear-screen) ()
  255.   (send self ':fresh-line)
  256.   (setq cursor-x 0)
  257.   (setq cursor-y 0))
  258.  
  259. (defmethod (ps-terminal :clear-eol) ()
  260.   (send self ':fresh-line))
  261.  
  262. (DEFMETHOD (ps-terminal :STRING-OUT) (STRING &OPTIONAL (START 0) END)
  263.   (or end (setq end (string-length string)))
  264.   (do ((j start (1+ j)))
  265.       ((= j end))
  266.     (send self ':tyo (aref string j))))
  267.  
  268. (defmethod (ps-terminal :fresh-line) ()
  269.   (or (zerop cursor-x) (send self ':tyo #\return)))
  270.  
  271. (defmethod (ps-terminal :clear-input) ()
  272.   (setq peek-chars nil)
  273.   (setq read-ahead-chars nil)
  274.   (send serial ':clear-input))
  275.  
  276.  
  277.  
  278. ;; this :read-cursopos caused lossage when it was defined and attempted to be
  279. ;; used from a lisp listener debugger.
  280.  
  281. #|
  282.  
  283. (defmethod (ps-terminal :read-cursorpos) (&optional (unit ':pixel))
  284.   (selectq unit
  285.     (:pixel (values (* cursor-x 10.) (* cursor-y 10.)))
  286.     (:character (values cursor-x cursor-y))))
  287.  
  288. |#
  289.  
  290.  
  291. #|
  292. ;; this is the old definition from system 94.
  293.  
  294. #-3600
  295. (DEFMETHOD (ps-terminal :RUBOUT-HANDLER) (tv:RUBOUT-HANDLER-OPTIONS FUNCTION &REST ARGS)
  296.   (LET ((PROMPT-OPTION (ASSQ ':PROMPT tv:RUBOUT-HANDLER-OPTIONS)))
  297.     (send self ':fresh-line)
  298.     (AND PROMPT-OPTION
  299.            (TV:RUBOUT-HANDLER-PROMPT (CADR PROMPT-OPTION) SELF NIL))
  300.     (setq buffer nil)
  301.     (DO ((tv:RUBOUT-HANDLER T))
  302.           (NIL)
  303.       (*CATCH 'tv:RUBOUT-HANDLER
  304.           (CONDITION-CASE (ERROR)
  305.               (RETURN (APPLY FUNCTION ARGS))
  306.             (SYS:READ-ERROR
  307.              (TERPRI SELF)
  308.              (PRINC ">>ERROR: " SELF)
  309.              (SEND ERROR ':REPORT SELF)
  310.              (TERPRI SELF)
  311.              (DO () (NIL) (FUNCALL-SELF ':TYI))))))))
  312.  
  313. |#
  314.  
  315. ;; in system 99 we had to start again from the definition of (stream-mixin :rubout-handler)
  316. ;; and hack it up again. Given the STREAM-RUBOUT-HANDLER instance variable we could
  317. ;; mixin STREAM-MIXIN to out stream, and rewrite things to use what is provided
  318. ;; by (stream-mixin :rubout-handler). Because this is a hacked-to-work version
  319. ;; of another function some variables it binds/sets/references might not
  320. ;; actually be doing anything.
  321.  
  322. #-3600
  323. (defmethod (ps-terminal :rubout-handler) (options function &rest args)
  324.   (declare (arglist rubout-handler-options function &rest args))
  325.   (if (and (eq rubout-handler self) (not (cdr (assq :nonrecursive options))))
  326.       (let ((tv:rubout-handler-options (append options tv:rubout-handler-options)))
  327.           (apply function args))
  328.     (let ((tv:rubout-handler-options options))
  329.       (setq buffer nil status :initial-entry)
  330.       (*catch 'return-from-rubout-handler
  331.           (let (tv:prompt-starting-x tv:prompt-starting-y
  332.                 tv:rubout-handler-starting-x tv:rubout-handler-starting-y
  333.                 (tv:rubout-handler self)
  334.                 (tv:rubout-handler-inside self)
  335.                 (tv:rubout-handler-re-echo-flag nil)
  336.                 (tv:rubout-handler-activation-character nil))
  337.             (setq tv:prompt-starting-x cursor-x
  338.                     tv:prompt-starting-y cursor-y)
  339.             (setq tv:rubout-handler-starting-x tv:prompt-starting-x
  340.                     tv:rubout-handler-starting-y tv:prompt-starting-y)
  341.             (do-forever
  342.               (setq tv:rubout-handler-re-echo-flag nil)
  343.               (*catch 'tv:rubout-handler                              ;Throw here when rubbing out
  344.                 (condition-case (error)
  345.                       (return
  346.                        (apply function args))
  347.                     (sys:parse-error
  348.                      (send self :fresh-line)
  349.                      (princ ">>ERROR: " self)
  350.                      (send error :report self)
  351.                      (send self :fresh-line)
  352.                      (setq tv:rubout-handler-re-echo-flag t)
  353.                      (do-forever (send self :tyi)))))       ;If error, force user to rub out
  354.               ;;Maybe return when user rubs all the way back
  355.               (and (null peek-chars)
  356.                      (let ((full-rubout-option (assq :full-rubout tv:rubout-handler-options)))
  357.                        (when full-rubout-option
  358.                          ;; Get rid of the prompt, if any.
  359.                          (send self :fresh-line)
  360.                          (return nil (cadr full-rubout-option)))))))))))
  361.  
  362. (defun ps-terminal-echo-loop (x)
  363.   (do ((c))(nil)
  364.     (setq c (send x ':tyi))
  365.     (send x ':tyo c)))
  366.  
  367. (defun ps-terminal-repl-test (x)
  368.   (let ((error-output terminal-io)
  369.           (debug-io terminal-io))
  370.     (si:lisp-top-level1 x)))
  371.  
  372.  
  373. ;; The remote login and server loop.
  374.  
  375. (defun answer-call (x)
  376.     (tyi x)
  377.     (format x "~%~A" (send si:local-host :name)))
  378.  
  379. (defun ps-kermit-login (x)
  380.   "This is the toplevel loop for login to get to the command interpreter"
  381.   (prog (user-info)
  382.      answer-call
  383.      (answer-call x)
  384.      validate-password
  385.      (cond ((setq user-info (valid-password? x))
  386.               (welcome-user x user-info)
  387.               (kermit-remote-loop x)
  388.               (hangup-call x)
  389.               (go answer-call))
  390.              ('else
  391.               (format x "~&Bad username or password")
  392.               (go validate-password)))))
  393.  
  394.  
  395. (defconst *hangup-call* "+++" "a string for ascii modem control of hangup")
  396.  
  397. (defun hangup-call (x)
  398.   "the +++ characters are for experimental use with the US Robotics modem"
  399.   (format x "~&HANGUP at ~A~%~A"
  400.             (time:print-current-date nil)
  401.             *hangup-call*))
  402.  
  403. (defvar ps-kermit-default-pathname)
  404.  
  405. (defun welcome-user (x info)
  406.   (setq ps-kermit-default-pathname (or (catch-error (fs:make-pathname ':host "LM"
  407.                                                                                       ':directory (car info)))
  408.                                                (fs:make-pathname :host "LM"
  409.                                                                        :directory "TMP")))
  410.   (format x "~&~A logged in at ~A~%" (car info) (time:print-current-date nil)))
  411.  
  412. #-3600 (define-site-variable *ps-kermit-login-passwords* :kermit-login-accounts    ;1; not on 3600
  413.   #-3600 "Example use in DEFSITE:        ;1; this doesn't take on 3600
  414.  (:kermit-login-accounts (/"gjc/" /"mobyfoo/") (/"rg/" /"mobywin/"))")
  415.  
  416. #+3600 (defvar *ps-kermit-login-passwords* nil "Temporary kludge for 3600.")    ;1;
  417.  
  418. (defun add-ps-terminal-account (username password)
  419.   (check-arg username stringp "a string")
  420.   (check-arg password stringp "a string")
  421.   (push (list username password) *ps-kermit-login-passwords*)
  422.   t)
  423.  
  424. (deff authorize 'add-ps-terminal-account)
  425. (deff passwd 'add-ps-terminal-account)
  426.  
  427. (defvar *ps-kermit-login-fails* nil)
  428.  
  429. (defvar *ps-kermit-login-wins* nil)
  430.  
  431. #-3600
  432. (defun valid-password? (x)
  433.   (let ((uname (prompt-and-read-s x :string-trim "~&Username: "))
  434.           (password (let ((*rubout-handler-echo? nil))
  435.                         (prompt-and-read-s x :string-trim "~&Password: ")))
  436.           (data))
  437.     (cond ((or (and (null *ps-kermit-login-passwords*)
  438.                         (null (get-site-option ':kermit-server-passwords))
  439.                         (progn (format x "~&;NULL password database. So ~S gets in free.~%"
  440.                                            uname)
  441.                                  (setq data (list uname password))))
  442.                  (and (or (setq data (ass #'string-equal uname *ps-kermit-login-passwords*))
  443.                               (setq data (ass #'string-equal uname
  444.                                                   (get-site-option ':kermit-server-passwords))))
  445.                         (string-equal (cadr data) password)))
  446.              (push (list (time:print-current-date nil) uname password)
  447.                      *ps-kermit-login-wins*)
  448.              data)
  449.             ('else
  450.              (push (list (time:print-current-date nil) uname password)
  451.                      *ps-kermit-login-fails*)
  452.              nil))))
  453.  
  454.  
  455. (defmacro def-kermit-remote-loop-command (name argl documentation &body body)
  456.   (or (symbolp name)
  457.       (ferror nil "name of command not a symbol: ~S" name))
  458.   `(progn 'compile
  459.             (or (memq ',name *kermit-remote-loop-commands*)
  460.                 (push ',name *kermit-remote-loop-commands*))
  461.             (defprop ,name ,documentation kermit-loop-documentation)
  462.             (defun (:property ,name kermit-loop-command) ,argl ,@body)))
  463.  
  464. (defvar *kermit-remote-loop-commands* nil)
  465.  
  466. (defun prompt-and-read-s (query-io &rest prompt-and-read-arguments)
  467.   "see prompt-and-read"
  468.   (lexpr-funcall #'prompt-and-read prompt-and-read-arguments))
  469.  
  470. (defun kermit-remote-loop (stream)
  471.   (*catch 'kermit-remote-loop
  472.     (do ((command-line)(command)(index)(argument)(symbol))
  473.           (nil)
  474.       (do ()
  475.             ((setq command-line (prompt-and-read-s stream :string-trim "~&Kermit-Q>"))))
  476.       (cond ((setq index (string-search-set '(#\space #\tab) command-line))
  477.                (setq command (substring command-line 0 index))
  478.                (setq argument (substring command-line (1+ index))))
  479.               ('else
  480.                (setq command command-line)
  481.                (setq argument nil)))
  482.       (cond ((setq symbol (car (mem #'string-equal command *kermit-remote-loop-commands*)))
  483.                (call-kermit-loop-command symbol stream argument))
  484.               ('else
  485.                (format stream "~&Unknown command: ~A~%" command))))))
  486.  
  487. (defvar call-kermit-loop-command ':no-debug)
  488.  
  489. (defvar *cl-arg* nil)
  490.  
  491. (defun call-kermit-loop-command (sym stream &optional *cl-arg*)
  492.   (cond ((eq call-kermit-loop-command ':debug)
  493.            (funcall (get sym 'kermit-loop-command) stream))
  494.           ((catch-error (progn (funcall (get sym 'kermit-loop-command) stream) t)))
  495.           (t (format stream "~%**FATAL ERROR IN COMMAND: ~S **~%" SYM)
  496.              (*throw 'kermit-remote-loop stream))))
  497.  
  498. (def-kermit-remote-loop-command ? (stream) "Pointer to help"
  499.   (format stream "~&Type HELP for help."))
  500.  
  501. (def-kermit-remote-loop-command HELP (stream) "prints this information"
  502.   (do ((max-width (+ 4 (apply #'max (mapcar #'flatc *kermit-remote-loop-commands*))))
  503.        (l (reverse *kermit-remote-loop-commands*) (cdr l)))
  504.       ((null l))
  505.     (format stream "~&~V,,,'.<~A ~;~> ~A~%" max-width (car l)
  506.               (get (car l) 'kermit-loop-documentation))))
  507.  
  508. (def-kermit-remote-loop-command TIME (stream) "prints the current time"
  509.   (time:print-current-date stream))
  510.  
  511. (def-kermit-remote-loop-command  LOGOUT (stream) "and hangup the call"
  512.   (*throw 'kermit-remote-loop stream))
  513.  
  514. (def-kermit-remote-loop-command SERVER (x) "goes into kermit server mode."
  515.   (declare (special kermit:kermit-default-pathname))
  516.   (setq kermit:kermit-default-pathname
  517.           (format nil "~A:~:[~A~;~{~A~^.~}~];"
  518.                     (send ps-kermit-default-pathname ':host)
  519.                     (listp (send ps-kermit-default-pathname ':directory))
  520.                     (send ps-kermit-default-pathname ':directory)))
  521.   (if (eq (progw (mapcan #'(lambda (x) (if (not (boundp (car x))) (list x)))
  522.                                 '((kermit:interaction-pane terminal-io)
  523.                                   (kermit:debug-pane terminal-io)
  524.                                   (kermit:status-pane terminal-io)))
  525.               ;; bind these variables just in case and for debugging purposes.
  526.               (format x "~& [ Now entering server mode. Now use your local escape sequence ]~
  527.                        ~% [ to return to your local kermit command interpreter.          ]~%")
  528.               (kermit:kermit-remote-server (send x ':raw-stream)
  529.                                                    ps-kermit-default-pathname))
  530.             ':logout)
  531.       (call-kermit-loop-command 'logout x)))
  532.  
  533. (def-kermit-remote-loop-command PWD (x) "print working directory"
  534.   (format x "~&Default pathname: ~S~%" ps-kermit-default-pathname))
  535.  
  536.  
  537. (defun get-cl-arg-pathname (x prompt)
  538.   (let ((string (or *cl-arg*
  539.                         (prompt-and-read-s x :string "~&~A" prompt))))
  540.     (let ((*error-output* x))
  541.       (catch-error (#-3600 merge-pathnames #+3600 fs:merge-pathnames string ps-kermit-default-pathname)))))
  542.  
  543. (def-kermit-remote-loop-command CD (x) "change directory"
  544.   (let ((p (get-cl-arg-pathname x "Default Pathname> ")))
  545.     (and p (setq ps-kermit-default-pathname p)))
  546.   (call-kermit-loop-command 'pwd x))
  547.  
  548. (def-kermit-remote-loop-command DIR (x) "print a directory listing (of pwd)"
  549.   (let ((dir (send ps-kermit-default-pathname ':new-pathname
  550.                        ':name ':wild
  551.                        ':type ':wild
  552.                        ':version ':newest)))
  553.     (Let ((dirstream (catch-error (fs:directory-list-stream dir))))
  554.       (cond (dirstream
  555.                (unwind-protect
  556.                      (with-puntable-output
  557.                        (let ((e (send dirstream ':entry)))
  558.                          (format x "~&Directory: ~A~%~A~%"
  559.                                    (get e ':pathname)
  560.                                    (get e ':disk-space-description))
  561.                          (do ((f))
  562.                                ((null (setq f (send dirstream ':entry))))
  563.                            (format x "~A ~D bytes~%"
  564.                                      (car f) (get f ':length-in-bytes)))))
  565.                  (send dirstream ':close)))
  566.               ('else
  567.                (format x "~&Bad default pathname: ~A~%" ps-kermit-default-pathname))))))
  568.  
  569.  
  570. (def-kermit-remote-loop-command EVAL (x) "evaluate a single lisp form"
  571.   (cond (*cl-arg*
  572.            (let ((*error-output* x))
  573.              (catch-error (prin1 (eval (read-from-string *cl-arg*)) x))))))
  574.  
  575. (def-kermit-remote-loop-command repl (x) "enter a read-eval-print loop"
  576.   (format x "~%Entering READ//EVAL//PRINT. Say (*THROW ':REPL NIL) to exit~%~%")
  577.   (*catch ':repl
  578.     (LET ((STANDARD-INPUT (MAKE-SYNONYM-STREAM '*TERMINAL-IO*))
  579.             (STANDARD-OUTPUT (MAKE-SYNONYM-STREAM '*TERMINAL-IO*))
  580.             (QUERY-IO (MAKE-SYNONYM-STREAM '*TERMINAL-IO*))
  581.             (TRACE-OUTPUT (MAKE-SYNONYM-STREAM '*TERMINAL-IO*))
  582.             (ERROR-OUTPUT (MAKE-SYNONYM-STREAM '*TERMINAL-IO*))
  583.             (DEBUG-IO (MAKE-SYNONYM-STREAM '*TERMINAL-IO*)))
  584.       (si:lisp-top-level1 x))))
  585.  
  586. (def-kermit-remote-loop-command herald (x) "print software and site version information"
  587.   (with-puntable-output (print-herald x)))
  588.  
  589.  
  590. (def-kermit-remote-loop-command type (X) "print a file on the terminal"
  591.   (let ((f (get-cl-arg-pathname x "filename to type> ")))
  592.     (if (and f (probef f))
  593.           (with-puntable-output
  594.             (with-open-file (stream f)
  595.               (stream-copy-until-eof stream x)))
  596.       (format x "~&File does not exists: ~S~%" f))))
  597.  
  598.  
  599. ;; making and debugging.
  600.  
  601. (defflavor s-terminal-debug-window
  602.              ((ps-terminal-stream nil)
  603.               (baud-rate 1200.))
  604.              (tv:notification-mixin tv:process-mixin tv:window)
  605.   (:default-init-plist
  606.     :save-bits t
  607.     :process '(s-terminal-debug-process :SPECIAL-PDL-SIZE #o4000
  608.                                                   :REGULAR-PDL-SIZE #o10000))
  609.   :initable-instance-variables
  610.     )
  611.  
  612. (defmethod (s-terminal-debug-window :after :init)
  613.              (ignore)
  614.   (funcall-self ':activate)
  615.   (funcall-self ':expose)
  616.   (funcall-self ':select))
  617.  
  618. (defmethod (s-terminal-debug-window :clean-up-stuff) ()
  619.   (close (send ps-terminal-stream ':raw-stream)))
  620.  
  621. (defun s-terminal-debug-process (terminal-io)
  622.   (send terminal-io ':doit-loop))
  623.  
  624. (defmethod (s-terminal-debug-window :doit-loop) ()
  625.   (send self ':set-more-p nil)
  626.   (send self ':set-deexposed-typeout-action ':permit)
  627.   (cond ((null ps-terminal-stream)
  628.            (format t "Initializing Kermit remote login~%")
  629.            (setq ps-terminal-stream (make-ps-terminal))
  630.            (format t "Done. Now go back to your other window if you wish.~%")
  631.            ;(tv:deselect-and-maybe-bury-window self nil)
  632.            ))
  633.   (send (send ps-terminal-stream ':raw-stream) ':set-baud-rate baud-rate)
  634.   (ps-kermit-login ps-terminal-stream))
  635.  
  636. (defmethod (s-terminal-debug-window :primitive-loop) ()
  637.   (ps-terminal-echo-loop ps-terminal-stream))
  638.  
  639. (defconst *ps-terminal-debug-window* nil)
  640.  
  641. (defun cleanup-s-terminal-debug-window ()
  642.   (send *ps-terminal-debug-window* ':clean-up-stuff)
  643.   (send *ps-terminal-debug-window* ':kill)
  644.   (setq *ps-terminal-debug-window* nil))
  645.  
  646.  
  647.  
  648. ;;;--------------------------------------------------------------------------------
  649.  
  650. ;;; SETUP-S-TERMINAL-DEBUG-WINDOW (&rest options)
  651.  
  652. ;;; This is it: TOP LEVEL
  653. ;;; Call this fn, but realize that it makes a new serial stream instance,
  654. ;;; so the regular Kermit frame should not be used unless you set it up
  655. ;;; with a new serial stream. This makes a window on which you can see
  656. ;;; trace output of your fave fns, and on which kermit prints out its
  657. ;;; usual messages.
  658.  
  659. (DEFUN SETUP-S-TERMINAL-DEBUG-WINDOW (&REST OPTIONS)
  660.   (IF *PS-TERMINAL-DEBUG-WINDOW*
  661.       (CLEANUP-S-TERMINAL-DEBUG-WINDOW))
  662.   (SETQ *PS-TERMINAL-DEBUG-WINDOW*
  663.           (LEXPR-FUNCALL #'MAKE-INSTANCE 'S-TERMINAL-DEBUG-WINDOW OPTIONS))
  664.   (TV:AWAIT-WINDOW-EXPOSURE))
  665.  
  666. ;;;--------------------------------------------------------------------------------
  667.  
  668. ;; For some kind of interactive eval server from the unix/streams interface.
  669.  
  670. (defmethod (s-terminal-debug-window :unix-doit-loop) ()
  671.   (format t "INITIALIZING...NOW GO TO OTHER WINDOW~%")
  672.   (send self ':set-more-p nil)
  673.   (send self ':set-deexposed-typeout-action ':permit)
  674.   (ps-kermit-login ps-terminal-stream))
  675.  
  676. (defun unix-terminal-debug-process (terminal-io)
  677.   (send terminal-io ':unix-doit-loop))
  678.  
  679. (defun setup-unix-terminal-debug-window ()
  680.   (make-instance 's-terminal-debug-window
  681.                      ':process '(unix-terminal-debug-process)
  682.                      ':ps-terminal-stream (make-instance
  683.                                                   'ps-terminal
  684.                                                   ':serial (symeval (intern "*UNIX-PORT-1*" "UNIX"))
  685.                                                   ':peek-chars nil
  686.                                                   ':read-ahead-chars nil
  687.                                                   ':ttysync t))
  688.   (TV:AWAIT-WINDOW-EXPOSURE))
  689.